home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / WINDOWS / WXLSLIB.ARJ / ROTATE.LSP < prev    next >
Lisp/Scheme  |  1992-02-20  |  5KB  |  134 lines
  1. #+macintosh(require "addbox" ":Examples:addbox")
  2. #+macintosh(require "addhandrotate" ":Examples:addhandrotate")
  3. #+macintosh(require ":Data:tutorial")
  4. #+unix(require "addbox" "Examples/addbox")
  5. #+unix(require "addhandrotate" "Examples/addhandrotate")
  6. #+unix(load-data "tutorial")
  7. #+msdos(require "addbox" "Examples\\addbox")
  8. #+msdos(require "addhandrotate" "Examples\\addhandr")
  9. #+msdos(load-data "tutorial")
  10.  
  11. (defun sphere-rand (n &optional (dim 3))
  12.   (mapcar #'(lambda (k) 
  13.               (do ((x 
  14.                     (- (* 2 (uniform-rand k)) 1) 
  15.                     (- (* 2 (uniform-rand k)) 1)))
  16.                   ((< (sum (* x x)) 1) x))) (repeat dim n)))
  17.  
  18. (defmeth spin-proto :data-rotate (&optional axis (angle pi))
  19.   (unless axis
  20.           (setf axis (choose-item-dialog "Axis:" '("X" "Y" "Z")))
  21.           (if axis (setf axis (select '(x y z) axis)))
  22.           (send self :redraw))
  23.   (if axis
  24.       (let* ((alpha (send self :angle))
  25.              (cols (column-list 
  26.                     (let ((m (send self :transformation)))
  27.                        (if m m (identity-matrix 3)))))
  28.              (m (case axis
  29.                   (x (make-rotation (nth 1 cols) (nth 2 cols) alpha))
  30.                   (y (make-rotation (nth 0 cols) (nth 2 cols) alpha))
  31.                   (z (make-rotation (nth 0 cols) (nth 1 cols) alpha)))))
  32.         (dotimes (i (floor (/ angle alpha)))
  33.                  (send self :apply-transformation m)))))
  34.  
  35. (defmeth spin-proto :toggle-box ()
  36.   (if (not (send self :has-slot 'has-box :own t))
  37.       (send self :add-slot 'has-box))
  38.   (let ((has-box (slot-value 'has-box)))
  39.     (if (not has-box) (send self :add-box) (send self :clear-lines :draw nil))
  40.     (send self :redraw)
  41.     (setf (slot-value 'has-box) (not has-box))))
  42.  
  43. (defmeth spin-proto :rock-plot (&optional (n 10) (k 3))
  44.   (let ((a (send self :angle)))
  45.     (dotimes (i k) (send self :rotate-2 0 2 (- a)))
  46.     (dotimes (i n)
  47.              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 a))
  48.              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 (- a))))))
  49.  
  50. (defun add-demo-menu-items (bar)
  51.   (send (send bar :menu) :append-items 
  52.         (send dash-item-proto :new)
  53.         (send menu-item-proto :new "Toggle Box" :action 
  54.               #'(lambda () (send bar :toggle-box)))
  55.         (send menu-item-proto :new "Toggle Scaling" :action
  56.               #'(lambda ()
  57.                   (send bar :scale-type
  58.                         (if (eq (send bar :scale-type) 'fixed)
  59.                             'variable
  60.                             'fixed))))
  61.         (send menu-item-proto :new "Rotate..." :action
  62.               #'(lambda () (send bar :data-rotate)))
  63.         (send menu-item-proto :new "Rock Plot" :key #\R :action
  64.               #'(lambda () (send bar :rock-plot)))))
  65.  
  66. (defun make-bar-demo ()
  67.   (close-all-plots)
  68.   (def bar (spin-plot (let* ((x1 (* 20 (uniform-rand 40)))
  69.                              (x2 (normal-rand 40))
  70.                              (y (normal-rand 40)))
  71.                         (list x1 y x2))
  72.                       :variable-labels '("X1" "Y" "X2")
  73.                       :scale 'fixed))
  74.   (send bar :depth-cuing nil)
  75.   (send bar :redraw)
  76.   (add-demo-menu-items bar))
  77.  
  78. (defun make-abrasion-demo ()
  79.   (close-all-plots)
  80.   (def abr (spin-plot (list tensile-strength abrasion-loss hardness) 
  81.                       :variable-labels '("T" "A" "H")))
  82.   (add-demo-menu-items abr))
  83.  
  84. (defun make-spheres-demo ()
  85.   (close-all-plots)
  86.   (let ((x (sphere-rand 100)))
  87.     (def p1 (spin-plot (transpose x)))
  88.     (add-demo-menu-items p1)
  89.     (def p2 (spin-plot (transpose (mapcar 
  90.                                    #'(lambda (x) 
  91.                                        (let ((n (sqrt (sum (* x x))))) 
  92.                                          (* (+ .8 (* .2 n)) (/ x n)))) x))))
  93.     (send p2 :location 250 21) 
  94.     (add-demo-menu-items p2)))
  95.  
  96. (defun make-randu-demo ()
  97.   (close-all-plots)
  98.   #+macintosh (require ":Data:randu")
  99.   #+unix (load-data "randu")
  100.   (let ((p (spin-plot randu))) (add-demo-menu-items p))
  101.   (undef 'randu))
  102.  
  103. (defun make-diabetes-demo ()
  104.   (close-all-plots)
  105.   #+macintosh (require ":Data:diabetes")
  106.   #+unix (load-data "diabetes")
  107.   (let ((p (spin-plot (select diabetes '(0 1 2))
  108.                       :variable-labels (select dlabs '(0 1 2)))))
  109.     (add-demo-menu-items p))
  110.   (undef 'diabetes))
  111.  
  112. (setf demo-menu (send menu-proto :new "Demos"))
  113. (send demo-menu :append-items
  114.       (send menu-item-proto :new "Bar" :action
  115.             #'(lambda () (make-bar-demo)))
  116.       (send menu-item-proto :new "Abrasion" :action
  117.             #'(lambda () (make-abrasion-demo)))
  118.       (send menu-item-proto :new "Spheres" :action
  119.             #'(lambda () (make-spheres-demo)))
  120.       (send menu-item-proto :new "Randu" :action
  121.             #'(lambda () (make-randu-demo)))
  122.       (send menu-item-proto :new "Diabetes" :action
  123.             #'(lambda () (make-diabetes-demo))))
  124. (send demo-menu :install)
  125.  
  126. (defun demo (which)
  127.   (case which
  128.     (bar (make-bar-demo))
  129.     (abrasion (make-abrasion-demo))
  130.     (spheres (make-spheres-demo))
  131.     (randu (make-randu-demo))
  132.     (diabetes (make-diabetes-demo))))
  133.  
  134.